home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / fpc / sources.fpc / comp.sources.unix_1486_000003.msg < prev   
Encoding:
Internet Message Format  |  1993-08-10  |  44.6 KB
  1. Path: iam!chx400!cernvax!mcsun!uunet!bbn.com!rsalz
  2. From: rsalz@uunet.uu.net (Rich Salz)
  3. Newsgroups: comp.sources.unix
  4. Subject: v20i053:  Portable compiler of the FP language, Part04/06
  5. Message-ID: <2061@papaya.bbn.com>
  6. Date: 24 Oct 89 16:05:37 GMT
  7. Lines: 1577
  8. Approved: rsalz@uunet.UU.NET
  9.  
  10. Submitted-by: Edoardo Biagioni <biagioni@cs.unc.edu>
  11. Posting-number: Volume 20, Issue 53
  12. Archive-name: fpc/part04
  13.  
  14. #    This is a shell archive.
  15. #    Remove everything above and including the cut line.
  16. #    Then run the rest of the file through sh.
  17. -----cut here-----cut here-----cut here-----cut here-----
  18. #!/bin/sh
  19. # shar:    Shell Archiver
  20. #    Run the following text with /bin/sh to create:
  21. #    fp.c.part2
  22. #    mkffp.c
  23. echo shar: extracting fp.c.part2 '(34144 characters)'
  24. sed 's/^XX//' << \SHAR_EOF > fp.c.part2
  25. XX
  26. XXfp_data apndr (data)
  27. XXfp_data data;
  28. XX{
  29. XX  register fp_data vector, el, res, prev, next;
  30. XX
  31. XX#ifdef DEBUG
  32. XX  (void) fprintf (stderr, "entering apndr, object is ");
  33. XX  printfpdata (stderr, data, 0);
  34. XX  (void) putc ('\n', stderr);
  35. XX#endif
  36. XX#ifndef NOCHECK
  37. XX  if (data->fp_type != VECTOR)
  38. XX    genbottom ("apndr: input is not a vector", data);
  39. XX  if ((data->fp_header.fp_next == 0) ||
  40. XX      (data->fp_header.fp_next->fp_header.fp_next != 0))
  41. XX    genbottom ("apndr: input is not a 2-element vector", data);
  42. XX#endif
  43. XX  vector = data->fp_entry;
  44. XX  el = data->fp_header.fp_next->fp_entry;
  45. XX#ifndef NOCHECK
  46. XX  if (nonvector (vector))
  47. XX    genbottom ("apndr: 1st element is not a vector or nil", data);
  48. XX#endif
  49. XX  if (vector->fp_type != VECTOR)        /* nil? */
  50. XX    vector = 0;
  51. XX  prev = 0;        /* copy the first argument */
  52. XX  while (vector != 0)
  53. XX  {
  54. XX    next = newcell ();
  55. XX    if (vector != data->fp_entry)
  56. XX      prev->fp_header.fp_next = next;
  57. XX    else
  58. XX      res = next;
  59. XX    next->fp_entry = vector->fp_entry;
  60. XX    inc_ref (next->fp_entry);
  61. XX    prev = next;
  62. XX    vector = vector->fp_header.fp_next;
  63. XX  }
  64. XX  next = newcell ();    /* cons the second argument to the right */
  65. XX  next->fp_entry = el;
  66. XX  inc_ref (el);
  67. XX  if (prev == 0)
  68. XX    res = next;
  69. XX  else
  70. XX    prev->fp_header.fp_next = next;
  71. XX  dec_ref (data);
  72. XX#ifdef DEBUG
  73. XX  (void) fprintf (stderr, "exiting apndr, result is ");
  74. XX  printfpdata (stderr, res, 0);
  75. XX  (void) putc ('\n', stderr);
  76. XX#endif
  77. XX  return (res);
  78. XX}
  79. XX
  80. XXvoid parmbot (fname, errdesc, data)
  81. XXchar * fname;
  82. XXchar * errdesc;
  83. XXfp_data data;
  84. XX{
  85. XX  char buffer [100];
  86. XX
  87. XX  (void) strcpy (buffer, fname);
  88. XX  (void) strcat (buffer, ": ");
  89. XX  (void) strcat (buffer, errdesc);
  90. XX  genbottom (buffer, data);
  91. XX}
  92. XX
  93. XXint compare ();
  94. XX
  95. XXint compvectors (v1, v2)
  96. XXfp_data v1, v2;
  97. XX/* like compare, but for v1, v2 assumed vectors or 0 (not checked) */
  98. XX{
  99. XX  register int tempres;
  100. XX
  101. XX  if (v1 == v2)
  102. XX    return (0);
  103. XX  if (v1 == 0)
  104. XX    return (- 1);
  105. XX  if (v2 == 0)
  106. XX    return (1);
  107. XX/* compare the heads */
  108. XX  if ((tempres = compare (v1->fp_entry, v2->fp_entry)) != 0)
  109. XX    return (tempres);
  110. XX/* heads are same, compare tails */
  111. XX  return (compvectors (v1->fp_header.fp_next, v2->fp_header.fp_next));
  112. XX}
  113. XX
  114. XXint compare (op1, op2)
  115. XXfp_data op1, op2;
  116. XX/* compares the two objects (numbers, symbols, nil, true, false, vectors)
  117. XX * in data and returns an int > 0, = 0 or < 0 depending on the first being
  118. XX * greater, equal to or less than the second. Also takes care
  119. XX * of error messages. Returns the input data.
  120. XX * notice: F < T < num < atom < char < nil < vector
  121. XX */
  122. XX{
  123. XX  register int result = 0;
  124. XX  register int type1, type2;
  125. XX  register float num1, num2;
  126. XX  register float eps;
  127. XX#define ONEPLUSEPSILON 1.0001
  128. XX#define ONEMINUSEPSILON (2.0 - ONEPLUSEPSILON)
  129. XX
  130. XX  type1 = op1->fp_type;
  131. XX  type2 = op2->fp_type;
  132. XX  if ((type1 == type2) && (type1 != FLOATCONST))
  133. XX            /* floats are handled in the else if */
  134. XX    switch (type1)
  135. XX    {
  136. XX      case INTCONST:
  137. XX        return (op1->fp_header.fp_int - op2->fp_header.fp_int);
  138. XX      case CHARCONST:
  139. XX    return (op1->fp_header.fp_char - op2->fp_header.fp_char);
  140. XX      case ATOMCONST:
  141. XX    result = strcmp (op1->fp_header.fp_atom, op2->fp_header.fp_atom);
  142. XX    break;
  143. XX      case VECTOR:    /* use an arbitrary ordering! */
  144. XX    result = compvectors (op1, op2);
  145. XX    break;
  146. XX      default:        /* nil, true, false */
  147. XX    /* do nothing, equality of types implies equality of data */
  148. XX    ;
  149. XX    }
  150. XX  else if (((type1 == INTCONST) || (type1 == FLOATCONST)) &&
  151. XX       ((type2 == INTCONST) || (type2 == FLOATCONST)))
  152. XX  {
  153. XX    num1 = ((type1 == INTCONST) ? op1->fp_header.fp_int :
  154. XX                  op1->fp_header.fp_float);
  155. XX    num2 = ((type2 == INTCONST) ? op2->fp_header.fp_int :
  156. XX                  op2->fp_header.fp_float);
  157. XX    eps = (num1 >= 0.0) ? ONEPLUSEPSILON : ONEMINUSEPSILON;
  158. XX    if ((num1 * eps) < num2)
  159. XX      result = -1;
  160. XX    else if ((num1 / eps) > num2)
  161. XX      result = 1;
  162. XX    else
  163. XX      result = 0;
  164. XX  }
  165. XX  else if (type1 < type2)
  166. XX    result = -1;
  167. XX  else if (type1 > type2)
  168. XX    result = 1;
  169. XX  else
  170. XX    result = 0;
  171. XX  return (result);
  172. XX}
  173. XX
  174. XXfp_data eq (data)
  175. XXfp_data data;
  176. XX{
  177. XX  register fp_data res;
  178. XX
  179. XX#ifdef DEBUG
  180. XX  (void) fprintf (stderr, "entering eq, object is ");
  181. XX  printfpdata (stderr, data, 0);
  182. XX  (void) putc ('\n', stderr);
  183. XX#endif
  184. XX  checkpair (data, "eq");
  185. XX  if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) == 0)
  186. XX    res = fp_true;
  187. XX  else
  188. XX    res = fp_false;
  189. XX  dec_ref (data);
  190. XX#ifdef DEBUG
  191. XX  (void) fprintf (stderr, "exiting eq, result is ");
  192. XX  printfpdata (stderr, res, 0);
  193. XX  (void) putc ('\n', stderr);
  194. XX#endif
  195. XX  return (res);
  196. XX}
  197. XX
  198. XXfp_data notequal (data)
  199. XXfp_data data;
  200. XX{
  201. XX  register fp_data res;
  202. XX
  203. XX#ifdef DEBUG
  204. XX  (void) fprintf (stderr, "entering notequal, object is ");
  205. XX  printfpdata (stderr, data, 0);
  206. XX  (void) putc ('\n', stderr);
  207. XX#endif
  208. XX  checkpair (data, "eq");
  209. XX  if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) != 0)
  210. XX    res = fp_true;
  211. XX  else
  212. XX    res = fp_false;
  213. XX  dec_ref (data);
  214. XX#ifdef DEBUG
  215. XX  (void) fprintf (stderr, "exiting notequal, result is ");
  216. XX  printfpdata (stderr, res, 0);
  217. XX  (void) putc ('\n', stderr);
  218. XX#endif
  219. XX  return (res);
  220. XX}
  221. XX
  222. XXfp_data lequal (data)
  223. XXfp_data data;
  224. XX{
  225. XX  register fp_data res;
  226. XX
  227. XX#ifdef DEBUG
  228. XX  (void) fprintf (stderr, "entering lequal, object is ");
  229. XX  printfpdata (stderr, data, 0);
  230. XX  (void) putc ('\n', stderr);
  231. XX#endif
  232. XX  checkpair (data, "lequal");
  233. XX  if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) <= 0)
  234. XX    res = fp_true;
  235. XX  else
  236. XX    res = fp_false;
  237. XX  dec_ref (data);
  238. XX#ifdef DEBUG
  239. XX  (void) fprintf (stderr, "exiting lequal, result is ");
  240. XX  printfpdata (stderr, res, 0);
  241. XX  (void) putc ('\n', stderr);
  242. XX#endif
  243. XX  return (res);
  244. XX}
  245. XX
  246. XXfp_data less (data)
  247. XXfp_data data;
  248. XX{
  249. XX  register fp_data res;
  250. XX
  251. XX#ifdef DEBUG
  252. XX  (void) fprintf (stderr, "entering less, object is ");
  253. XX  printfpdata (stderr, data, 0);
  254. XX  (void) putc ('\n', stderr);
  255. XX#endif
  256. XX  checkpair (data, "less");
  257. XX  if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) < 0)
  258. XX    res = fp_true;
  259. XX  else
  260. XX    res = fp_false;
  261. XX  dec_ref (data);
  262. XX#ifdef DEBUG
  263. XX  (void) fprintf (stderr, "exiting less, result is ");
  264. XX  printfpdata (stderr, res, 0);
  265. XX  (void) putc ('\n', stderr);
  266. XX#endif
  267. XX  return (res);
  268. XX}
  269. XX
  270. XXfp_data gequal (data)
  271. XXfp_data data;
  272. XX{
  273. XX  register fp_data res;
  274. XX
  275. XX#ifdef DEBUG
  276. XX  (void) fprintf (stderr, "entering gequal, object is ");
  277. XX  printfpdata (stderr, data, 0);
  278. XX  (void) putc ('\n', stderr);
  279. XX#endif
  280. XX  checkpair (data, "gequal");
  281. XX  if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) >= 0)
  282. XX    res = fp_true;
  283. XX  else
  284. XX    res = fp_false;
  285. XX  dec_ref (data);
  286. XX#ifdef DEBUG
  287. XX  (void) fprintf (stderr, "exiting gequal, result is ");
  288. XX  printfpdata (stderr, res, 0);
  289. XX  (void) putc ('\n', stderr);
  290. XX#endif
  291. XX  return (res);
  292. XX}
  293. XX
  294. XXfp_data greater (data)
  295. XXfp_data data;
  296. XX{
  297. XX  register fp_data res;
  298. XX
  299. XX#ifdef DEBUG
  300. XX  (void) fprintf (stderr, "entering greater, object is ");
  301. XX  printfpdata (stderr, data, 0);
  302. XX  (void) putc ('\n', stderr);
  303. XX#endif
  304. XX  checkpair (data, "greater");
  305. XX  if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) > 0)
  306. XX    res = fp_true;
  307. XX  else
  308. XX    res = fp_false;
  309. XX  dec_ref (data);
  310. XX#ifdef DEBUG
  311. XX  (void) fprintf (stderr, "exiting greater, result is ");
  312. XX  printfpdata (stderr, res, 0);
  313. XX  (void) putc ('\n', stderr);
  314. XX#endif
  315. XX  return (res);
  316. XX}
  317. XX
  318. XX#ifndef NOCHECK
  319. XXvoid checkarith (data, fname)
  320. XXfp_data data;
  321. XXchar * fname;
  322. XX{
  323. XX#ifdef DEBUG
  324. XX  (void) fprintf (stderr, "entering %s, object is ", fname);
  325. XX  printfpdata (stderr, data, 0);
  326. XX  (void) putc ('\n', stderr);
  327. XX#endif
  328. XX  if (data->fp_type != VECTOR)
  329. XX    parmbot (fname, "input is not a vector", data);
  330. XX  if ((data->fp_header.fp_next == 0) ||
  331. XX      (data->fp_header.fp_next->fp_header.fp_next != 0))
  332. XX    parmbot (fname, "input is not a 2-element vector", data);
  333. XX  if ((data->fp_entry->fp_type != INTCONST) &&
  334. XX      (data->fp_entry->fp_type != FLOATCONST))
  335. XX    parmbot (fname, "1st argument is not a number", data);
  336. XX  if ((data->fp_header.fp_next->fp_entry->fp_type != INTCONST) &&
  337. XX      (data->fp_header.fp_next->fp_entry->fp_type != FLOATCONST))
  338. XX    parmbot (fname, "second argument is not a number", data);
  339. XX}
  340. XX
  341. XX#endif
  342. XX
  343. XXfp_data plus (data)
  344. XXfp_data data;
  345. XX{
  346. XX  register fp_data res;
  347. XX  register float op1, op2;
  348. XX  register int isint = 1;
  349. XX
  350. XX#ifndef NOCHECK
  351. XX  checkarith (data, "plus");
  352. XX#endif
  353. XX  if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
  354. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
  355. XX  else
  356. XX  {
  357. XX    isint = 0;
  358. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
  359. XX  }
  360. XX  if (data->fp_entry->fp_type == INTCONST)
  361. XX    op1 = data->fp_entry->fp_header.fp_int;
  362. XX  else
  363. XX  {
  364. XX    isint = 0;
  365. XX    op1 = data->fp_entry->fp_header.fp_float;
  366. XX  }
  367. XX#ifndef NOCHECK
  368. XX  if (isint && ((op1 < 0) == (op2 < 0)) &&
  369. XX      ((MAXINT - abs (op1)) < abs (op2)))
  370. XX    genbottom ("plus: overflow or underflow", data);
  371. XX#endif
  372. XX  if (isint)
  373. XX  {
  374. XX    res = newconst (INTCONST);
  375. XX    res->fp_header.fp_int = op1 + op2;
  376. XX  }
  377. XX  else
  378. XX  {
  379. XX    res = newconst (FLOATCONST);
  380. XX    res->fp_header.fp_float = op1 + op2;
  381. XX  }
  382. XX  dec_ref (data);
  383. XX#ifdef DEBUG
  384. XX  (void) fprintf (stderr, "exiting plus, result is ");
  385. XX  printfpdata (stderr, res, 0);
  386. XX  (void) putc ('\n', stderr);
  387. XX#endif
  388. XX  return (res);
  389. XX}
  390. XX
  391. XXfp_data minus (data)
  392. XXfp_data data;
  393. XX{
  394. XX  register fp_data res;
  395. XX  register float op1, op2;
  396. XX  register int isint = 1;
  397. XX
  398. XX#ifndef NOCHECK
  399. XX  checkarith (data, "minus");
  400. XX#endif
  401. XX  if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
  402. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
  403. XX  else
  404. XX  {
  405. XX    isint = 0;
  406. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
  407. XX  }
  408. XX  if (data->fp_entry->fp_type == INTCONST)
  409. XX    op1 = data->fp_entry->fp_header.fp_int;
  410. XX  else
  411. XX  {
  412. XX    isint = 0;
  413. XX    op1 = data->fp_entry->fp_header.fp_float;
  414. XX  }
  415. XX#ifndef NOCHECK
  416. XX  if (isint && ((op1 < 0) != (op2 < 0)) &&
  417. XX      ((MAXINT - abs (op1)) < abs (op2)))
  418. XX    genbottom ("minus: overflow or underflow", data);
  419. XX#endif
  420. XX  if (isint)
  421. XX  {
  422. XX    res = newconst (INTCONST);
  423. XX    res->fp_header.fp_int = op1 - op2;
  424. XX  }
  425. XX  else
  426. XX  {
  427. XX    res = newconst (FLOATCONST);
  428. XX    res->fp_header.fp_float = op1 - op2;
  429. XX  }
  430. XX  dec_ref (data);
  431. XX#ifdef DEBUG
  432. XX  (void) fprintf (stderr, "exiting minus, result is ");
  433. XX  printfpdata (stderr, res, 0);
  434. XX  (void) putc ('\n', stderr);
  435. XX#endif
  436. XX  return (res);
  437. XX}
  438. XX
  439. XXfp_data fptimes (data)
  440. XXfp_data data;
  441. XX{
  442. XX  register fp_data res;
  443. XX  register float op1, op2;
  444. XX  register int isint = 1;
  445. XX
  446. XX#ifndef NOCHECK
  447. XX  checkarith (data, "times");
  448. XX#endif
  449. XX  if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
  450. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
  451. XX  else
  452. XX  {
  453. XX    isint = 0;
  454. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
  455. XX  }
  456. XX  if (data->fp_entry->fp_type == INTCONST)
  457. XX    op1 = data->fp_entry->fp_header.fp_int;
  458. XX  else
  459. XX  {
  460. XX    isint = 0;
  461. XX    op1 = data->fp_entry->fp_header.fp_float;
  462. XX  }
  463. XX#ifndef NOCHECK
  464. XX  if (isint && (op1 != 0) && ((MAXINT / abs (op1)) < abs (op2)))
  465. XX/* the second condition is to insure that the test does not overflow */
  466. XX    genbottom ("times: arithmetic overflow", data);
  467. XX#endif
  468. XX  if (isint)
  469. XX  {
  470. XX    res = newconst (INTCONST);
  471. XX    res->fp_header.fp_int = op1 * op2;
  472. XX  }
  473. XX  else
  474. XX  {
  475. XX    res = newconst (FLOATCONST);
  476. XX    res->fp_header.fp_float = op1 * op2;
  477. XX  }
  478. XX  dec_ref (data);
  479. XX#ifdef DEBUG
  480. XX  (void) fprintf (stderr, "exiting times, result is ");
  481. XX  printfpdata (stderr, res, 0);
  482. XX  (void) putc ('\n', stderr);
  483. XX#endif
  484. XX  return (res);
  485. XX}
  486. XX
  487. XXfp_data div (data)
  488. XXfp_data data;
  489. XX{
  490. XX  register fp_data res;
  491. XX  register float op1, op2, intermediate;
  492. XX  register int isint = 1;
  493. XX
  494. XX#ifndef NOCHECK
  495. XX  checkarith (data, "div");
  496. XX#endif
  497. XX  if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
  498. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
  499. XX  else
  500. XX  {
  501. XX    isint = 0;
  502. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
  503. XX  }
  504. XX  if (data->fp_entry->fp_type == INTCONST)
  505. XX    op1 = data->fp_entry->fp_header.fp_int;
  506. XX  else
  507. XX  {
  508. XX    isint = 0;
  509. XX    op1 = data->fp_entry->fp_header.fp_float;
  510. XX  }
  511. XX#ifndef NOCHECK
  512. XX  if (op2 == 0.0)
  513. XX    genbottom ("div: division by 0", data);
  514. XX#endif
  515. XX  if (isint)
  516. XX  {
  517. XX    res = newconst (INTCONST);
  518. XX    intermediate = op1 / op2;
  519. XX    res->fp_header.fp_int = intermediate;
  520. XX    if ((res->fp_header.fp_int < 0) &&
  521. XX    (res->fp_header.fp_int != intermediate))
  522. XX      res->fp_header.fp_int--;
  523. XX  }
  524. XX  else
  525. XX  {
  526. XX    res = newconst (FLOATCONST);
  527. XX    res->fp_header.fp_float = op1 / op2;
  528. XX  }
  529. XX  dec_ref (data);
  530. XX#ifdef DEBUG
  531. XX  (void) fprintf (stderr, "exiting div, result is ");
  532. XX  printfpdata (stderr, res, 0);
  533. XX  (void) putc ('\n', stderr);
  534. XX#endif
  535. XX  return (res);
  536. XX}
  537. XX
  538. XXfp_data mod (data)
  539. XXfp_data data;
  540. XX{
  541. XX  register fp_data res;
  542. XX  register long op1, op2;
  543. XX
  544. XX#ifndef NOCHECK
  545. XX  checkarith (data, "mod");
  546. XX#endif
  547. XX  if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
  548. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
  549. XX  else
  550. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
  551. XX  if (data->fp_entry->fp_type == INTCONST)
  552. XX    op1 = data->fp_entry->fp_header.fp_int;
  553. XX  else
  554. XX    op1 = data->fp_entry->fp_header.fp_float;
  555. XX#ifndef NOCHECK
  556. XX  if (op2 == 0.0)
  557. XX    genbottom ("mod: division by 0", data);
  558. XX#endif
  559. XX  res = newconst (INTCONST);
  560. XX  res->fp_header.fp_int = op1 % op2;
  561. XX  if (res->fp_header.fp_int < 0)
  562. XX    res->fp_header.fp_int += abs (op2);
  563. XX  if ((op2 < 0) && (res->fp_header.fp_int != 0))
  564. XX    res->fp_header.fp_int = (- op2) - res->fp_header.fp_int;
  565. XX  dec_ref (data);
  566. XX#ifdef DEBUG
  567. XX  (void) fprintf (stderr, "exiting mod, result is ");
  568. XX  printfpdata (stderr, res, 0);
  569. XX  (void) putc ('\n', stderr);
  570. XX#endif
  571. XX  return (res);
  572. XX}
  573. XX
  574. XXfp_data neg (data)
  575. XXfp_data data;
  576. XX{
  577. XX  register fp_data res;
  578. XX
  579. XX#ifdef DEBUG
  580. XX  (void) fprintf (stderr, "entering neg, object is ");
  581. XX  printfpdata (stderr, data, 0);
  582. XX  (void) putc ('\n', stderr);
  583. XX#endif
  584. XX#ifndef NOCHECK
  585. XX  if ((data->fp_type != INTCONST) && (data->fp_type != FLOATCONST))
  586. XX    genbottom ("neg: input is not a number", data);
  587. XX#endif
  588. XX  res = newconst (data->fp_type);
  589. XX  if (data->fp_type == INTCONST)
  590. XX    res->fp_header.fp_int = - data->fp_header.fp_int;
  591. XX  else
  592. XX    res->fp_header.fp_float = - data->fp_header.fp_float;
  593. XX  dec_ref (data);
  594. XX#ifdef DEBUG
  595. XX  (void) fprintf (stderr, "exiting neg, result is ");
  596. XX  printfpdata (stderr, res, 0);
  597. XX  (void) putc ('\n', stderr);
  598. XX#endif
  599. XX  return (res);
  600. XX}
  601. XX
  602. XXfp_data null (data)
  603. XXfp_data data;
  604. XX{
  605. XX  register fp_data res;
  606. XX
  607. XX#ifdef DEBUG
  608. XX  (void) fprintf (stderr, "entering null, argument is ");
  609. XX  printfpdata (stderr, data, 0);
  610. XX  (void) putc ('\n', stderr);
  611. XX#endif
  612. XX  if (data->fp_type == NILOBJ)
  613. XX    res = (fp_true);
  614. XX  else
  615. XX    res = (fp_false);
  616. XX  dec_ref (data);
  617. XX#ifdef DEBUG
  618. XX  (void) fprintf (stderr, "exiting null, result is ");
  619. XX  printfpdata (stderr, res, 0);
  620. XX  (void) putc ('\n', stderr);
  621. XX#endif
  622. XX  return (res);
  623. XX}
  624. XX
  625. XXfp_data length (data)
  626. XXfp_data data;
  627. XX{
  628. XX  register fp_data res, vector;
  629. XX  register long size;
  630. XX
  631. XX#ifdef DEBUG
  632. XX  (void) fprintf (stderr, "entering length, object is ");
  633. XX  printfpdata (stderr, data, 0);
  634. XX  (void) putc ('\n', stderr);
  635. XX#endif
  636. XX#ifndef NOCHECK
  637. XX  if (nonvector (data))
  638. XX    genbottom ("length: input is not a vector or nil", data);
  639. XX#endif
  640. XX  size = 0;
  641. XX  if (data->fp_type == NILOBJ)
  642. XX    vector = 0;
  643. XX  else
  644. XX    vector = data;
  645. XX  while (vector != 0)
  646. XX  {
  647. XX    size++;
  648. XX    vector = vector->fp_header.fp_next;
  649. XX  }
  650. XX  res = newconst (INTCONST);
  651. XX  res->fp_header.fp_int = size;
  652. XX  dec_ref (data);
  653. XX#ifdef DEBUG
  654. XX  (void) fprintf (stderr, "exiting length, result is ");
  655. XX  printfpdata (stderr, res, 0);
  656. XX  (void) putc ('\n', stderr);
  657. XX#endif
  658. XX  return (res);
  659. XX}
  660. XX
  661. XXfp_data trans (data)
  662. XXfp_data data;
  663. XX{
  664. XX/* implementation: a matrix backbone is the set of storage cells that
  665. XX   point to rows of the matrix. What we do is we copy the argument's
  666. XX   backbone, then use it to step through all elements of the first
  667. XX   column while updating the backbone to point to the second column
  668. XX   and building a result row, and repeat. */
  669. XX  register fp_data fromptr,    /* holds the "from" part when pointer chasing */
  670. XX           toptr,    /* holds the "to" part when pointer chasing */
  671. XX           resptr,    /* holds a copy of the result backbone */
  672. XX           bbcopy,    /* holds a copy of the matrix backbone */
  673. XX             res;        /* holds the final result */
  674. XX  register long rows = 1, cols = 1;
  675. XX
  676. XX#ifdef DEBUG
  677. XX  (void) fprintf (stderr, "entering trans, object is ");
  678. XX  printfpdata (stderr, data, 0);
  679. XX  (void) putc ('\n', stderr);
  680. XX#endif
  681. XX#ifndef NOCHECK
  682. XX  if (data->fp_type != VECTOR)
  683. XX    genbottom ("trans: input is not a vector", data);
  684. XX#endif
  685. XX  if (data->fp_entry->fp_type != VECTOR)
  686. XX  {    /* The loop is for legality check only. */
  687. XX    /* it is legal to tranpose a vector of nils into nil. */
  688. XX    /* the converse (nil to a vector of nils) is not legal. */
  689. XX    /* that is the only case in which trans o trans != id. */
  690. XX#ifndef NOCHECK
  691. XX    for (fromptr = data; fromptr != 0; fromptr = fromptr->fp_header.fp_next)
  692. XX      if (fromptr->fp_entry->fp_type != NILOBJ)
  693. XX    genbottom ("trans: input is not a matrix", data);
  694. XX#endif
  695. XX    res = fp_nil;
  696. XX  }
  697. XX  else
  698. XX  {        /* find out number of source cols = dest rows */
  699. XX    fromptr = data->fp_entry;
  700. XX    while ((fromptr = fromptr->fp_header.fp_next) != 0)
  701. XX      cols++;
  702. XX            /* now find out number of source rows = dest cols */
  703. XX    fromptr = data;
  704. XX    while ((fromptr = fromptr->fp_header.fp_next) != 0)
  705. XX      rows++;
  706. XX    bbcopy = newvect (rows);    /* copy the old backbone to bbcopy */
  707. XX    fromptr = data;
  708. XX    toptr = bbcopy;
  709. XX    while (fromptr != 0)
  710. XX    {
  711. XX      toptr->fp_entry = fromptr->fp_entry;
  712. XX/* no need to inc_ref since we will reset the backbone to be
  713. XX   all NILs before returning it. */
  714. XX      toptr = toptr->fp_header.fp_next;
  715. XX      fromptr = fromptr->fp_header.fp_next;
  716. XX    }        /* backbone copied, now start building output rows */
  717. XX    res = newvect (cols);        /* the result has "cols" rows */
  718. XX    resptr = res;
  719. XX    while (resptr != 0) /* build one row at a time, and assign it to */
  720. XX    { /* resptr->fp_entry, so we are done when resptr is 0 */
  721. XX/* loop invariant: every time we enter the loop, we are (inductively)
  722. XX   building the transpose of bbcopy into resptr. When we finish
  723. XX   each loop, we will have removed the first column of bbcopy and built
  724. XX   the top row of resptr, and changed bbcopy to remove its first column. */
  725. XX      resptr->fp_entry = toptr = newvect (rows);
  726. XX      fromptr = bbcopy;
  727. XX/* resptr is the backbone of res. fromptr runs along bbcopy
  728. XX   and updates it to point to the next element of each row. toptr
  729. XX   runs along the current result row to initialize it. */
  730. XX      while (toptr != 0)    /* here we build one row of res */
  731. XX      {
  732. XX#ifndef NOCHECK
  733. XX    if (fromptr->fp_entry == 0)
  734. XX      genbottom ("trans: rows are not all equally long", data);
  735. XX#endif
  736. XX    toptr->fp_entry = fromptr->fp_entry->fp_entry;
  737. XX    inc_ref (toptr->fp_entry);
  738. XX    fromptr->fp_entry = fromptr->fp_entry->fp_header.fp_next;
  739. XX/* make the backbone so it points to the next element of the row,
  740. XX   in effect deleting this element of the first column from bbcopy. */
  741. XX    fromptr = fromptr->fp_header.fp_next;
  742. XX    toptr = toptr->fp_header.fp_next;
  743. XX      }        /* the row of result is built, go on to the next. */
  744. XX      resptr = resptr->fp_header.fp_next;
  745. XX    }
  746. XX    for (fromptr = bbcopy; fromptr != 0; fromptr = fromptr->fp_header.fp_next)
  747. XX#ifndef NOCHECK
  748. XX      if (fromptr->fp_entry != 0)
  749. XX    genbottom ("trans: rows are not all equally long", data);
  750. XX      else
  751. XX#endif
  752. XX    fromptr->fp_entry = fp_nil;
  753. XX    dec_ref (bbcopy);
  754. XX  }
  755. XX  dec_ref (data);
  756. XX#ifdef DEBUG
  757. XX  (void) fprintf (stderr, "exiting trans, result is ");
  758. XX  printfpdata (stderr, res, 0);
  759. XX  (void) putc ('\n', stderr);
  760. XX#endif
  761. XX  return (res);
  762. XX}
  763. XX
  764. XX#ifndef NOCHECK
  765. XXvoid checklog (data, fname)
  766. XXfp_data data;
  767. XXchar * fname;
  768. XX{
  769. XX#ifdef DEBUG
  770. XX  (void) fprintf (stderr, "entering %s, object is ", fname);
  771. XX  printfpdata (stderr, data, 0);
  772. XX  (void) putc ('\n', stderr);
  773. XX#endif
  774. XX  if (data->fp_type != VECTOR)
  775. XX    parmbot (fname, "input is not a vector", data);
  776. XX  if ((data->fp_header.fp_next == 0) ||
  777. XX      (data->fp_header.fp_next->fp_header.fp_next != 0))
  778. XX    parmbot (fname, "input is not a 2-element vector", data);
  779. XX  if (nonboolean (data->fp_entry))
  780. XX    parmbot (fname, "1st argument is not a boolean", data);
  781. XX  if (nonboolean (data->fp_header.fp_next->fp_entry))
  782. XX    parmbot (fname, "second argument is not a boolean", data);
  783. XX}
  784. XX#endif
  785. XX
  786. XXfp_data and (data)
  787. XXfp_data data;
  788. XX{
  789. XX  register fp_data res;
  790. XX  register fp_data op1, op2;
  791. XX
  792. XX#ifndef NOCHECK
  793. XX  checklog (data, "and");
  794. XX#endif
  795. XX  op1 = data->fp_entry;
  796. XX  op2 = data->fp_header.fp_next->fp_entry;
  797. XX  if ((op1->fp_type == TRUEOBJ) &&
  798. XX      (op2->fp_type == TRUEOBJ))
  799. XX    res = (fp_true);
  800. XX  else
  801. XX    res = (fp_false);
  802. XX  dec_ref (data);
  803. XX#ifdef DEBUG
  804. XX  (void) fprintf (stderr, "exiting and, result is ");
  805. XX  printfpdata (stderr, res, 0);
  806. XX  (void) putc ('\n', stderr);
  807. XX#endif
  808. XX  return (res);
  809. XX}
  810. XX
  811. XXfp_data or (data)
  812. XXfp_data data;
  813. XX{
  814. XX  register fp_data res, op1, op2;
  815. XX
  816. XX#ifndef NOCHECK
  817. XX  checklog (data, "or");
  818. XX#endif
  819. XX  op1 = data->fp_entry;
  820. XX  op2 = data->fp_header.fp_next->fp_entry;
  821. XX  if ((op1->fp_type == TRUEOBJ) ||
  822. XX      (op2->fp_type == TRUEOBJ))
  823. XX    res = (fp_true);
  824. XX  else
  825. XX    res = (fp_false);
  826. XX  dec_ref (data);
  827. XX#ifdef DEBUG
  828. XX  (void) fprintf (stderr, "exiting or, result is ");
  829. XX  printfpdata (stderr, res, 0);
  830. XX  (void) putc ('\n', stderr);
  831. XX#endif
  832. XX  return (res);
  833. XX}
  834. XX
  835. XXfp_data not (data)
  836. XXfp_data data;
  837. XX{
  838. XX  register fp_data res;
  839. XX
  840. XX#ifdef DEBUG
  841. XX  (void) fprintf (stderr, "entering not, object is ");
  842. XX  printfpdata (stderr, data, 0);
  843. XX  (void) putc ('\n', stderr);
  844. XX#endif
  845. XX#ifndef NOCHECK
  846. XX  if (nonboolean (data))
  847. XX    genbottom ("not: argument is not a boolean", data);
  848. XX#endif
  849. XX  if (data->fp_type == TRUEOBJ)
  850. XX    res = (fp_false);
  851. XX  else
  852. XX    res = (fp_true);
  853. XX  dec_ref (data);
  854. XX#ifdef DEBUG
  855. XX  (void) fprintf (stderr, "exiting not, result is ");
  856. XX  printfpdata (stderr, res, 0);
  857. XX  (void) putc ('\n', stderr);
  858. XX#endif
  859. XX  return (res);
  860. XX}
  861. XX
  862. XXfp_data iota (data)
  863. XXfp_data data;
  864. XX{
  865. XX  register fp_data res, num, vect;
  866. XX  register long pos, size;
  867. XX
  868. XX#ifdef DEBUG
  869. XX  (void) fprintf (stderr, "entering iota, object is ");
  870. XX  printfpdata (stderr, data, 0);
  871. XX  (void) putc ('\n', stderr);
  872. XX#endif
  873. XX#ifndef NOCHECK
  874. XX  if ((data->fp_type != INTCONST) && (data->fp_type != FLOATCONST))
  875. XX    genbottom ("iota: input is not a number", data);
  876. XX#endif
  877. XX  if (data->fp_type == INTCONST)
  878. XX    size = data->fp_header.fp_int;
  879. XX  else
  880. XX    size = data->fp_header.fp_float;
  881. XX#ifndef NOCHECK
  882. XX  if (size < 0)
  883. XX    genbottom ("iota: input is negative", data);
  884. XX#endif
  885. XX  if (size == 0)
  886. XX    return (fp_nil);
  887. XX  res = newvect (size);
  888. XX  vect = res;
  889. XX  pos = 0;
  890. XX  while (size > pos++)
  891. XX  {
  892. XX    num = newconst (INTCONST);
  893. XX    num->fp_header.fp_int = pos;
  894. XX    vect->fp_entry = num;
  895. XX    vect = vect->fp_header.fp_next;
  896. XX  }
  897. XX#ifdef DEBUG
  898. XX  (void) fprintf (stderr, "exiting iota, result is ");
  899. XX  printfpdata (stderr, res, 0);
  900. XX  (void) putc ('\n', stderr);
  901. XX#endif
  902. XX  return (res);
  903. XX}
  904. XX
  905. XX/* the following function is used very often, so it is included
  906. XX * here for speed, though it could be defined as \/(/apndl o apndr).
  907. XX * It is not mentioned in the Backus Turing award lecture. */
  908. XXfp_data append (data)
  909. XXfp_data data;
  910. XX{
  911. XX  register fp_data entry;    /* holds the vector being copied */
  912. XX  register fp_data new;        /* holds the next cell filled in for new */
  913. XX  register fp_data res;        /* holds final result, but tested often */
  914. XX  register fp_data old;        /* chases 'data' */
  915. XX
  916. XX#ifdef DEBUG
  917. XX  (void) fprintf (stderr, "entering append, argument is ");
  918. XX  printfpdata (stderr, data, 0);
  919. XX  (void) putc ('\n', stderr);
  920. XX#endif
  921. XX#ifndef NOCHECK    /* arg must be a vector of vectors or nils */
  922. XX  if (data->fp_type != VECTOR)
  923. XX    genbottom ("append: input is not a vector", data);
  924. XX#endif
  925. XX  res = 0;
  926. XX  for (entry = data->fp_entry, old = data->fp_header.fp_next;
  927. XX    old != 0;
  928. XX    entry = old->fp_entry, old = old->fp_header.fp_next)
  929. XX  {
  930. XX    if (entry->fp_type == VECTOR)
  931. XX    {    /* partial loop unrolling to avoid testing for res == 0 in the
  932. XX       inner (for) loop: */
  933. XX      if (res == 0)
  934. XX    new = res = newcell ();
  935. XX      else
  936. XX    new = new->fp_header.fp_next = newcell ();
  937. XX      new->fp_entry = entry->fp_entry;
  938. XX      inc_ref (new->fp_entry);
  939. XX      for (entry = entry->fp_header.fp_next;
  940. XX       entry != 0;        /* this condition tested at start! */
  941. XX       entry = entry->fp_header.fp_next)
  942. XX      {
  943. XX    new = new->fp_header.fp_next = newcell ();
  944. XX    new->fp_entry = entry->fp_entry;
  945. XX    inc_ref (new->fp_entry);
  946. XX      }
  947. XX    }
  948. XX#ifndef NOCHECK
  949. XX    else if (entry->fp_type != NILOBJ)
  950. XX      genbottom ("append: input is not a vector of nils or vectors", data);
  951. XX#endif
  952. XX  }
  953. XX  if (res == 0)
  954. XX#ifndef NOCHECK
  955. XX    if ((entry->fp_type != NILOBJ) && (entry->fp_type != VECTOR))
  956. XX      genbottom ("append: input is not a vector of nils or vectors", data);
  957. XX    else
  958. XX#endif
  959. XX    res = entry;
  960. XX  else
  961. XX    if (entry->fp_type == VECTOR)
  962. XX      new->fp_header.fp_next = entry;
  963. XX#ifndef NOCHECK
  964. XX    else if (entry->fp_type != NILOBJ)
  965. XX      genbottom ("append: input is not a vector of nils or vectors", data);
  966. XX#endif
  967. XX  inc_ref (entry);    /* doesn't hurt, even if entry is nil */
  968. XX  dec_ref (data);
  969. XX#ifdef DEBUG
  970. XX  (void) fprintf (stderr, "exiting append, result is ");
  971. XX  printfpdata (stderr, res, 0);
  972. XX  (void) putc ('\n', stderr);
  973. XX#endif
  974. XX  return (res);
  975. XX}
  976. XX
  977. XX/* following are the character functions which I have come up with,
  978. XX * namely newline, implode, explode */
  979. XX
  980. XX/* constant function returning the new-line character */
  981. XXfp_data newline (data)
  982. XXfp_data data;
  983. XX{
  984. XX  static struct fp_charc nlc =
  985. XX                {(short) CHARCONST, (short) 1, '\n'};
  986. XX  static struct fp_constant nl =
  987. XX                {(short) VECTOR, (short) 1, (long) 0, (fp_data) &nlc};
  988. XX  register fp_data res;
  989. XX
  990. XX#ifdef DEBUG
  991. XX  (void) fprintf (stderr, "entering newline, object is ");
  992. XX  printfpdata (stderr, data, 0);
  993. XX  (void) putc ('\n', stderr);
  994. XX#endif
  995. XX  dec_ref (data);
  996. XX  res = (fp_data) & (nl);
  997. XX  inc_ref (res);
  998. XX#ifdef DEBUG
  999. XX  (void) fprintf (stderr, "exiting newline\n");
  1000. XX#endif
  1001. XX  return (res);
  1002. XX}
  1003. XX
  1004. XXstatic fp_data toFPstring (str)
  1005. XXregister char * str;
  1006. XX{
  1007. XX  register fp_data chase, ch;
  1008. XX  register fp_data res;
  1009. XX
  1010. XX  if (*str == '\0')
  1011. XX    res = fp_nil;
  1012. XX  else
  1013. XX  {
  1014. XX    res = chase = newcell ();
  1015. XX    while (1)
  1016. XX    {
  1017. XX      ch = newconst (CHARCONST);
  1018. XX      ch->fp_header.fp_char = *(str++);
  1019. XX      chase->fp_entry = ch;
  1020. XX      if (*str == '\0')
  1021. XX        break;
  1022. XX      chase = chase->fp_header.fp_next = newcell ();
  1023. XX    }
  1024. XX  }
  1025. XX  return (res);
  1026. XX}
  1027. XX
  1028. XXstatic void toCstring (fp, c)
  1029. XXfp_data fp;
  1030. XXchar * c;
  1031. XX{
  1032. XX  for ( ; fp != 0; fp = fp->fp_header.fp_next)
  1033. XX    *(c++) = fp->fp_entry->fp_header.fp_char;
  1034. XX  *c = '\0';
  1035. XX}
  1036. XX
  1037. XXfp_data explode (data)
  1038. XXfp_data data;
  1039. XX{
  1040. XX  register fp_data res;
  1041. XX
  1042. XX#ifdef DEBUG
  1043. XX  (void) fprintf (stderr, "entering explode, object is ");
  1044. XX  printfpdata (stderr, data, 0);
  1045. XX  (void) putc ('\n', stderr);
  1046. XX#endif
  1047. XX#ifndef NOCHECK
  1048. XX  if (data->fp_type != ATOMCONST)
  1049. XX    genbottom ("explode: argument is not an atom", data);
  1050. XX#endif
  1051. XX  res = toFPstring (data->fp_header.fp_atom);
  1052. XX  dec_ref (data);
  1053. XX#ifdef DEBUG
  1054. XX  (void) fprintf (stderr, "exiting explode, object is ");
  1055. XX  printfpdata (stderr, res, 0);
  1056. XX  (void) putc ('\n', stderr);
  1057. XX#endif
  1058. XX  return (res);
  1059. XX}
  1060. XX
  1061. XXfp_data implode (data)
  1062. XXfp_data data;
  1063. XX{
  1064. XX  register unsigned len = 1;
  1065. XX  register fp_data res, chase;
  1066. XX  register char * str;
  1067. XX
  1068. XX#ifdef DEBUG
  1069. XX  (void) fprintf (stderr, "entering implode, object is ");
  1070. XX  printfpdata (stderr, data, 0);
  1071. XX  (void) putc ('\n', stderr);
  1072. XX#endif
  1073. XX#ifndef NOCHECK
  1074. XX  if (! isstring (data))
  1075. XX    genbottom ("implode: argument is not a string", data);
  1076. XX#endif
  1077. XX  for (chase = data; chase != 0; chase = chase->fp_header.fp_next)
  1078. XX    len++;
  1079. XX  res = newconst (ATOMCONST);
  1080. XX  res->fp_header.fp_atom = str = malloc (len);
  1081. XX  toCstring (data, str);
  1082. XX  dec_ref (data);
  1083. XX#ifdef DEBUG
  1084. XX  (void) fprintf (stderr, "exiting implode, object is ");
  1085. XX  printfpdata (stderr, res, 0);
  1086. XX  (void) putc ('\n', stderr);
  1087. XX#endif
  1088. XX  return (res);
  1089. XX}
  1090. XX
  1091. XX/* following is the real to integer conversion function. Note: to
  1092. XX * convert from integer to real, use (bu * 1.0) */
  1093. XX
  1094. XX/* function returning the floor of the value of any numeric parameter */
  1095. XXfp_data trunc (data)
  1096. XXfp_data data;
  1097. XX{
  1098. XX  register fp_data res;
  1099. XX
  1100. XX#ifdef DEBUG
  1101. XX  (void) fprintf (stderr, "entering trunc, object is ");
  1102. XX  printfpdata (stderr, data, 0);
  1103. XX  (void) putc ('\n', stderr);
  1104. XX#endif
  1105. XX  if (data->fp_type == INTCONST)    /* no-op */
  1106. XX    return (data);
  1107. XX#ifndef NOCHECK
  1108. XX  if (data->fp_type != FLOATCONST)
  1109. XX    genbottom ("trunc: argument is not a number", data);
  1110. XX#endif
  1111. XX  res = newconst (INTCONST);
  1112. XX  res->fp_header.fp_int = data->fp_header.fp_float;
  1113. XX  if (res->fp_header.fp_int > data->fp_header.fp_float)    /* adjust */
  1114. XX    res->fp_header.fp_int--;
  1115. XX  dec_ref (data);
  1116. XX#ifdef DEBUG
  1117. XX  (void) fprintf (stderr, "exiting trunc, object is ");
  1118. XX  printfpdata (stderr, res, 0);
  1119. XX  (void) putc ('\n', stderr);
  1120. XX#endif
  1121. XX  return (res);
  1122. XX}
  1123. XX
  1124. XX/* following are the I/O functions not described or hinted at in the
  1125. XX * Backus paper. They are documented one by one. */
  1126. XX
  1127. XX/* trace outputs its data, which must be a string, in raw output mode,
  1128. XX * and returns it */
  1129. XXfp_data trace (data)
  1130. XXfp_data data;
  1131. XX{
  1132. XX#ifdef DEBUG
  1133. XX  (void) fprintf (stderr, "entering trace, object is ");
  1134. XX  printfpdata (stderr, data, 0);
  1135. XX  (void) putc ('\n', stderr);
  1136. XX#endif
  1137. XX#ifndef NOCHECK
  1138. XX  if ((data->fp_type != NILOBJ) && ! isstring (data))
  1139. XX    genbottom ("trace: input is not a string", data);
  1140. XX#endif
  1141. XX  putfpstring (data, stderr);
  1142. XX#ifdef DEBUG
  1143. XX  (void) fprintf (stderr, "exiting trace, result is ");
  1144. XX  printfpdata (stderr, data, 0);
  1145. XX  (void) putc ('\n', stderr);
  1146. XX#endif
  1147. XX  return (data);
  1148. XX}
  1149. XX
  1150. XX/* takes as argument a string and the name of a function, and
  1151. XX * returns the file with the given name (opened for reading),
  1152. XX * which may be 0. It does not dec_ref data.
  1153. XX */
  1154. XXstatic FILE * openfile (data, funname)
  1155. XXfp_data data;
  1156. XXchar * funname;
  1157. XX{
  1158. XX  char name [FNAMELEN];
  1159. XX
  1160. XX#ifdef DEBUG
  1161. XX  (void) fprintf (stderr, "entering %s, object is ", funname);
  1162. XX  printfpdata (stderr, data, 0);
  1163. XX  (void) putc ('\n', stderr);
  1164. XX#endif
  1165. XX#ifndef NOCHECK
  1166. XX  if (! isstring (data))
  1167. XX  {
  1168. XX    sprintf (name, "%s: input is not a string", funname);
  1169. XX    genbottom (name, data);
  1170. XX  }
  1171. XX#endif
  1172. XX  toCstring (data, name);
  1173. XX  return (fopen (name, "r"));
  1174. XX}
  1175. XX
  1176. XXstatic void closefile (f, funname, data, res)
  1177. XXFILE * f;
  1178. XXchar * funname;
  1179. XXfp_data data, res;
  1180. XX{
  1181. XX  char errstr [100];
  1182. XX
  1183. XX  if (f != 0)
  1184. XX    if (fclose (f) == EOF)
  1185. XX#ifndef NOCHECK
  1186. XX    {
  1187. XX      sprintf (errstr, "%s: unable to close the file", funname);
  1188. XX      genbottom (errstr, data);
  1189. XX    }
  1190. XX#else
  1191. XX      ;
  1192. XX#endif
  1193. XX  dec_ref (data);
  1194. XX#ifdef DEBUG
  1195. XX  (void) fprintf (stderr, "exiting %s, result is ", res);
  1196. XX  printfpdata (stderr, res, 0);
  1197. XX  (void) putc ('\n', stderr);
  1198. XX#endif
  1199. XX}
  1200. XX
  1201. XX/* filetype takes as input a string and returns:
  1202. XX * none if the file does not exist
  1203. XX * empty if the file exists but has no data
  1204. XX * binary if the file contains non-textual characters
  1205. XX * data if the file can be read by the parser
  1206. XX * text otherwise.
  1207. XX * A text file can usually be read as data (just returns
  1208. XX * the first word as an atom; that is however still
  1209. XX * marked as text. It is data if it has a single symbol
  1210. XX * alone on the first nonblank line. A data file may
  1211. XX * usually be read as text.
  1212. XX */
  1213. XXfp_data filetype (data)
  1214. XXfp_data data;
  1215. XX{
  1216. XX  static struct fp_atom none =
  1217. XX                {(short) ATOMCONST, (short) 1, (char *) "none"};
  1218. XX  static struct fp_atom empty =
  1219. XX                {(short) ATOMCONST, (short) 1, (char *) "empty"};
  1220. XX  static struct fp_atom datafile =
  1221. XX                {(short) ATOMCONST, (short) 1, (char *) "data"};
  1222. XX  static struct fp_atom text =
  1223. XX                {(short) ATOMCONST, (short) 1, (char *) "text"};
  1224. XX  static struct fp_atom binary =
  1225. XX                {(short) ATOMCONST, (short) 1, (char *) "binary"};
  1226. XX  fp_data res;
  1227. XX  FILE * f;
  1228. XX  int intch;
  1229. XX  char c;
  1230. XX  int isbinfile ();
  1231. XX 
  1232. XX  f = openfile (data, "filetype");
  1233. XX  if (f == 0)
  1234. XX    res = (fp_data) & none;
  1235. XX  else if ((intch = getc (f)) == EOF)
  1236. XX    res = (fp_data) & empty;
  1237. XX  else
  1238. XX  {
  1239. XX/* criteria for datafile:
  1240. XX * the first nonempty line contains a symbol by itsef --> datafile
  1241. XX * the datafile begins with a parseable vector or string --> datafile
  1242. XX * else --> text file or binary file
  1243. XX */
  1244. XX    while (isspace (intch))    /* find the first nonempty line */
  1245. XX      intch = getc (f);
  1246. XX    if (isalpha (intch))    /* is it a symbol on an empty line? */
  1247. XX    {
  1248. XX      while (isalnum (intch))
  1249. XX        intch = getc (f);
  1250. XX      while ((intch == ' ') || (intch == '\t'))
  1251. XX        intch = getc (f);
  1252. XX      if ((intch == '\n') || (intch == EOF))
  1253. XX        res = (fp_data) & datafile;
  1254. XX      else if (isbinfile (f, intch))
  1255. XX    res = (fp_data) & binary;
  1256. XX      else
  1257. XX    res = (fp_data) & text;
  1258. XX    }
  1259. XX    else
  1260. XX    {
  1261. XX      c = intch;
  1262. XX      if (readfpdata (f, &c, 1) ->fp_type == TRUEOBJ)
  1263. XX    res = (fp_data) & datafile;
  1264. XX/* notice readfpdata returned the last character it read */
  1265. XX      else if (isbinfile (f, c))
  1266. XX    res = (fp_data) & binary;
  1267. XX      else
  1268. XX    res = (fp_data) & text;
  1269. XX    }
  1270. XX  }
  1271. XX  inc_ref (res);
  1272. XX  closefile (f, "filetype", data, res);
  1273. XX  return (res);
  1274. XX}
  1275. XX
  1276. XXstatic int isbinfile (f, ch)
  1277. XXFILE * f;
  1278. XXint ch;
  1279. XX{
  1280. XX  for (; ch != EOF; ch = getc (f))
  1281. XX    if (! (isprint (ch) || isspace (ch)))
  1282. XX      return (1);
  1283. XX  return (0);
  1284. XX}
  1285. XX
  1286. XXfp_data readfile (data)
  1287. XXfp_data data;
  1288. XX{
  1289. XX  FILE * f;
  1290. XX  int c;
  1291. XX  char input;
  1292. XX  fp_data res;
  1293. XX
  1294. XX  f = openfile (data, "readfile");
  1295. XX  if ((f == 0) || ((c = getc (f)) == EOF))
  1296. XX    res = fp_nil;
  1297. XX  else
  1298. XX  {
  1299. XX    input = c;
  1300. XX    res = readfpdata (f, &input, 0);
  1301. XX  }
  1302. XX  closefile (f, "readfile", data, res);
  1303. XX  return (res);
  1304. XX}
  1305. XX
  1306. XXfp_data inputfile (data)
  1307. XXfp_data data;
  1308. XX{
  1309. XX  fp_data res;
  1310. XX  FILE * f;
  1311. XX
  1312. XX  f = openfile (data, "inputfile");
  1313. XX  res = readfpstring (f);
  1314. XX  closefile (f, "inputfile", data, res);
  1315. XX  return (res);
  1316. XX}
  1317. XX
  1318. XX/* the next function ignores its input and returns the arguments
  1319. XX * given in the call to the program. The arguments are returned
  1320. XX * in the following form:
  1321. XX * <argopt*>, where
  1322. XX * argopt ::= "argument" | option
  1323. XX * option ::= <'option, "value"> | <'option, <>>
  1324. XX */
  1325. XXfp_data arguments (data)
  1326. XXfp_data data;
  1327. XX{
  1328. XX  static fp_data res = 0;    /* re-use it after it has been initialized */
  1329. XX  fp_data old, option;
  1330. XX
  1331. XX  dec_ref (data);
  1332. XX  if (res == 0)            /* do the work, once and for all */
  1333. XX  {
  1334. XX    if (fpargc == 1)        /* no arguments, options */
  1335. XX      res = fp_nil;
  1336. XX    while ((fpargc--) > 1)    /* else: read arguments in reverse order */
  1337. XX    {
  1338. XX      old = res;
  1339. XX      res = newcell ();
  1340. XX      res->fp_header.fp_next = old;
  1341. XX      if (fpargv [fpargc] [0] == '-')    /* it's an option */
  1342. XX      {
  1343. XX        option = newpair ();
  1344. XX        option->fp_entry = newconst (CHARCONST);
  1345. XX        option->fp_entry->fp_header.fp_char = fpargv [fpargc] [1];
  1346. XX        option->fp_header.fp_next->fp_entry =
  1347. XX      toFPstring (& (fpargv [fpargc] [2]));
  1348. XX      }
  1349. XX      else                /* it's an argument */
  1350. XX        res->fp_entry = toFPstring (fpargv [fpargc]);
  1351. XX    }
  1352. XX#ifndef NOCHECK
  1353. XX    old = staticstore;
  1354. XX    staticstore = newcell ();
  1355. XX    staticstore->fp_header.fp_next = old;
  1356. XX    staticstore->fp_entry = res;
  1357. XX#endif
  1358. XX  }
  1359. XX  inc_ref (res);
  1360. XX  return (res);
  1361. XX}
  1362. SHAR_EOF
  1363. if test 34144 -ne "`wc -c fp.c.part2`"
  1364. then
  1365. echo shar: error transmitting fp.c.part2 '(should have been 34144 characters)'
  1366. fi
  1367. echo shar: extracting mkffp.c '(5533 characters)'
  1368. sed 's/^XX//' << \SHAR_EOF > mkffp.c
  1369. XX/* mkffp.c: this file, when linked with the FP preprocessor, will
  1370. XX *        produce an FP to FFP compiler. The compiler will read in
  1371. XX *        one or more FP files and for each FP function defined
  1372. XX *        will produce a corresponding FFP file function.ffp.
  1373. XX */
  1374. XX
  1375. XX#include <stdio.h>
  1376. XX#include <strings.h>
  1377. XX#include "fpc.h"
  1378. XX#include "parse.h"
  1379. XX#include "code.h"
  1380. XX
  1381. XXFILE * outfile;
  1382. XX
  1383. XX/* set newname to "" to indicate that no file should be opened */
  1384. XXvoid newfname (oldname, newname)
  1385. XXchar * oldname, * newname;
  1386. XX{
  1387. XX  *newname = '\0';
  1388. XX}
  1389. XX
  1390. XXstatic void codeobj (tree)
  1391. XXfpexpr tree;
  1392. XX{
  1393. XX  switch (tree->exprtype)
  1394. XX  {
  1395. XX    case NIL:
  1396. XX      (void) fprintf (outfile, "<>");
  1397. XX      break;
  1398. XX    case TRUE:
  1399. XX      (void) fprintf (outfile, "T");
  1400. XX      break;
  1401. XX    case FALSE:
  1402. XX      (void) fprintf (outfile, "F");
  1403. XX      break;
  1404. XX    case INT:
  1405. XX      (void) fprintf (outfile, "%d", tree->fpexprv.intobj);
  1406. XX      break;
  1407. XX    case FLOAT:
  1408. XX      (void) fprintf (outfile, "%f", tree->fpexprv.floatobj);
  1409. XX      break;
  1410. XX    case SYM:
  1411. XX      (void) fprintf (outfile, "%s", tree->fpexprv.symbol);
  1412. XX      break;
  1413. XX    case CHAR:
  1414. XX      (void) fprintf (outfile, "'%c", tree->fpexprv.character);
  1415. XX      break;
  1416. XX    case LIST:
  1417. XX      (void) putc ('<', outfile);
  1418. XX      while (tree != 0)
  1419. XX      {
  1420. XX    codeobj (tree->fpexprv.listobj.listel);
  1421. XX        (void) putc (' ', outfile);
  1422. XX    tree = tree->fpexprv.listobj.listnext;
  1423. XX      }
  1424. XX      (void) fprintf (outfile, ">\n");
  1425. XX      break;
  1426. XX    default:
  1427. XX      yyerror ("compiler error 11");
  1428. XX  }
  1429. XX}
  1430. XX
  1431. XXstatic void codeexpr (tree)
  1432. XXfpexpr tree;
  1433. XX{
  1434. XX#define STKSIZE    128
  1435. XX  fpexpr stack [STKSIZE];
  1436. XX  int stkptr;
  1437. XX
  1438. XX  switch (tree->exprtype)
  1439. XX  {
  1440. XX    case COND:
  1441. XX      (void) fprintf (outfile, "<cond ");
  1442. XX      codeexpr (tree->fpexprv.conditional [0]);
  1443. XX      (void) putc (' ', outfile);
  1444. XX      codeexpr (tree->fpexprv.conditional [1]);
  1445. XX      (void) putc (' ', outfile);
  1446. XX      codeexpr (tree->fpexprv.conditional [2]);
  1447. XX      (void) fprintf (outfile, ">\n");
  1448. XX      break;
  1449. XX    case BUR:
  1450. XX    case BU:
  1451. XX      if (tree->exprtype != BU)
  1452. XX    (void) fprintf (outfile, "<bur ");
  1453. XX      else
  1454. XX    (void) fprintf (outfile, "<bu ");
  1455. XX      codeexpr (tree->fpexprv.bulr.bufun);
  1456. XX      (void) putc (' ', outfile);
  1457. XX      codeobj (tree->fpexprv.bulr.buobj);
  1458. XX      (void) fprintf (outfile, ">\n");
  1459. XX      break;
  1460. XX    case WHILE:
  1461. XX      (void) fprintf (outfile, "<while ");
  1462. XX      codeexpr (tree->fpexprv.whilestat [0]);
  1463. XX      (void) putc (' ', outfile);
  1464. XX      codeexpr (tree->fpexprv.whilestat [1]);
  1465. XX      (void) fprintf (outfile, ">\n");
  1466. XX      break;
  1467. XX    case COMP:
  1468. XX      (void) fprintf (outfile, "<compose ");
  1469. XX      stkptr = 0;
  1470. XX      while (tree != 0)
  1471. XX      {
  1472. XX    if (stkptr >= STKSIZE)
  1473. XX      yyerror ("compiler stack overflow, compose too long");
  1474. XX        stack [stkptr++] = tree->fpexprv.compconstr.compexpr;
  1475. XX    tree = tree->fpexprv.compconstr.compnext;
  1476. XX      }
  1477. XX      while (stkptr != 0)
  1478. XX      {
  1479. XX        codeexpr (stack [--stkptr]);
  1480. XX        (void) putc (' ', outfile);
  1481. XX      }
  1482. XX      (void) fprintf (outfile, ">\n");
  1483. XX      break;
  1484. XX    case AA:
  1485. XX      (void) fprintf (outfile, "<aa ");
  1486. XX      codeexpr (tree->fpexprv.aains);
  1487. XX      (void) fprintf (outfile, ">\n");
  1488. XX      break;
  1489. XX    case CONSTR:
  1490. XX      (void) fprintf (outfile, "<constr ");
  1491. XX      while (tree != 0)
  1492. XX      {
  1493. XX        codeexpr (tree->fpexprv.compconstr.compexpr);
  1494. XX        (void) putc (' ', outfile);
  1495. XX    tree = tree->fpexprv.compconstr.compnext;
  1496. XX      }
  1497. XX      (void) fprintf (outfile, ">\n");
  1498. XX      break;
  1499. XX    case TREE:
  1500. XX    case RINSERT:
  1501. XX    case INSERT:
  1502. XX      if ((tree->fpexprv.aains->exprtype == FNCALL) &&
  1503. XX      (strcmp (tree->fpexprv.aains->fpexprv.funcall, "plus") == 0))
  1504. XX        (void) fprintf (outfile, "plus");
  1505. XX      else if ((tree->fpexprv.aains->exprtype == FNCALL) &&
  1506. XX      (strcmp (tree->fpexprv.aains->fpexprv.funcall, "times") == 0))
  1507. XX        (void) fprintf (outfile, "times");
  1508. XX      else if ((tree->fpexprv.aains->exprtype == FNCALL) &&
  1509. XX      (strcmp (tree->fpexprv.aains->fpexprv.funcall, "and") == 0))
  1510. XX        (void) fprintf (outfile, "and");
  1511. XX      else if ((tree->fpexprv.aains->exprtype == FNCALL) &&
  1512. XX      (strcmp (tree->fpexprv.aains->fpexprv.funcall, "or") == 0))
  1513. XX        (void) fprintf (outfile, "or");
  1514. XX      else
  1515. XX      {
  1516. XX    if (tree->exprtype == TREE)
  1517. XX          (void) fprintf (outfile, "<tree ");
  1518. XX        else if (tree->exprtype == RINSERT)
  1519. XX          (void) fprintf (outfile, "<rinsert ");
  1520. XX        else /* (tree->exprtype == INSERT) */
  1521. XX          (void) fprintf (outfile, "<insert ");
  1522. XX        codeexpr (tree->fpexprv.aains);
  1523. XX        (void) fprintf (outfile, ">\n");
  1524. XX      }
  1525. XX      break;
  1526. XX    case RSEL:
  1527. XX      (void) fprintf (outfile, "<rselect %d>\n", tree->fpexprv.lrsel);
  1528. XX      break;
  1529. XX    case SEL:
  1530. XX      (void) fprintf (outfile, "<select %d>\n", tree->fpexprv.lrsel);
  1531. XX      break;
  1532. XX    case FNCALL:
  1533. XX      (void) fprintf (outfile, "%s", tree->fpexprv.funcall);
  1534. XX      break;
  1535. XX    default:
  1536. XX      if ((tree->exprtype >= NIL) && (tree->exprtype <= CHAR))
  1537. XX      {
  1538. XX    (void) fprintf (outfile, "<const ");
  1539. XX        codeobj (tree);
  1540. XX    (void) fprintf (outfile, ">\n");
  1541. XX      }
  1542. XX      else
  1543. XX        yyerror ("compiler error 10");
  1544. XX  }
  1545. XX}
  1546. XX
  1547. XX/* called for each source FP function */
  1548. XXvoid code (fun, tree)
  1549. XXchar * fun;
  1550. XXfpexpr tree;
  1551. XX{
  1552. XX  char name [256];
  1553. XX
  1554. XX  (void) strcpy (name, fun);
  1555. XX  (void) strcpy (name + strlen (fun), ".ffp");
  1556. XX  outfile = fopen (name, "w");
  1557. XX  if (outfile == 0)
  1558. XX  {
  1559. XX    (void) sprintf (name, "unable to open file %s, aborting\n", name);
  1560. XX    yyerror (name);
  1561. XX  }
  1562. XX  codeexpr (tree);
  1563. XX  (void) fclose (outfile);
  1564. XX}
  1565. XX
  1566. XX/* the following two functions are provided for compatibility */
  1567. XXvoid putfileheader (inname, outname)
  1568. XXchar * inname;
  1569. XXchar * outname;
  1570. XX{
  1571. XX}
  1572. XX
  1573. XXvoid putfiletail ()
  1574. XX{
  1575. XX}
  1576. SHAR_EOF
  1577. if test 5533 -ne "`wc -c mkffp.c`"
  1578. then
  1579. echo shar: error transmitting mkffp.c '(should have been 5533 characters)'
  1580. fi
  1581. #    End of shell archive
  1582. exit 0
  1583.  
  1584. -- 
  1585. Please send comp.sources.unix-related mail to rsalz@uunet.uu.net.
  1586. Use a domain-based address or give alternate paths, or you may lose out.
  1587.